home *** CD-ROM | disk | FTP | other *** search
/ Turnbull China Bikeride / Turnbull China Bikeride - Disc 1.iso / HENSA / MISC / SIOD.ARC / !Siod / Scm / pratt_scm < prev    next >
Lisp/Scheme  |  1993-03-01  |  6KB  |  301 lines
  1. ;; -*-mode:lisp-*-
  2. ;;
  3. ;; A simple Pratt-Parser for SIOD: 2-FEB-90, George Carrette, GJC@PARADIGM.COM
  4. ;; Siod version 2.4 may be obtained by anonymous FTP to BU.EDU (128.197.2.6)
  5. ;; Get the file users/gjc/siod-v2.4-shar
  6. ;;
  7. ;;                   COPYRIGHT (c) 1990 BY                       
  8. ;;     PARADIGM ASSOCIATES INCORPORATED, CAMBRIDGE, MASSACHUSETTS.
  9. ;;         See the source file SLIB.C for more information. 
  10. ;;
  11. ;;
  12. ;; Based on a theory of parsing presented in:                       
  13. ;;                                                                      
  14. ;;  Pratt, Vaughan R., ``Top Down Operator Precedence,''         
  15. ;;  ACM Symposium on Principles of Programming Languages         
  16. ;;  Boston, MA; October, 1973.                                   
  17. ;;                                                                      
  18.  
  19. ;; The following terms may be useful in deciphering this code:
  20.  
  21. ;; NUD -- NUll left Denotation (op has nothing to its left (prefix))
  22. ;; LED -- LEft Denotation      (op has something to left (postfix or infix))
  23.  
  24. ;; LBP -- Left Binding Power  (the stickiness to the left)
  25. ;; RBP -- Right Binding Power (the stickiness to the right)
  26. ;;
  27. ;;
  28.  
  29. ;; Example calls
  30. ;;
  31. ;; (pl '(f [ a ] = a + b / c)) => (= (f a) (+ a (/ b c)))
  32. ;;
  33. ;; (pl '(if g [ a COMMA b ] then a > b else k * c + a * b))
  34. ;;  => (if (g a b) (> a b) (+ (* k c) (* a b)))
  35. ;;
  36. ;; Notes: 
  37. ;;
  38. ;;   This code must be used with siod.scm loaded, in siod version 2.3
  39. ;;
  40. ;;   For practical use you will want to write some code to
  41. ;;   break up input into tokens.
  42.  
  43.  
  44. (defvar *eof* (list '*eof*))
  45.  
  46. ;; 
  47.  
  48. (defun pl (l)
  49.   ;; parse a list of tokens
  50.   (setq l (append l '($)))
  51.   (toplevel-parse (lambda (op arg)
  52.             (cond ((eq op 'peek)
  53.                (if l (car l) *eof*))
  54.               ((eq op 'get)
  55.                (if l (pop l) *eof*))
  56.               ((eq op 'unget)
  57.                (push arg l))))))
  58.  
  59. (defun peek-token (stream)
  60.   (stream 'peek nil))
  61.  
  62. (defun read-token (stream)
  63.   (stream 'get nil))
  64.  
  65. (defun unread-token (x stream)
  66.   (stream 'unget x))
  67.  
  68. (defun toplevel-parse (stream)
  69.   (if (eq *eof* (peek-token stream))
  70.       (read-token stream)
  71.     (parse -1 stream)))
  72.  
  73. (defun value-if-symbol (x)
  74.   (if (symbol? x)
  75.       (symbol-value x)
  76.     x))
  77.  
  78. (defun nudcall (token stream)
  79.   (if (symbol? token)
  80.       (if (get token 'nud)
  81.       ((value-if-symbol (get token 'nud)) token stream)
  82.     (if (get token 'led)
  83.         (error 'not-a-prefix-operator token)
  84.       token)
  85.     token)
  86.     token))
  87.  
  88. (defun ledcall (token left stream)
  89.   ((value-if-symbol (or (and (symbol? token)
  90.                  (get token 'led))
  91.             (error 'not-an-infix-operator token)))
  92.    token
  93.    left
  94.    stream))
  95.  
  96.  
  97. (defun lbp (token)
  98.   (or (and (symbol? token) (get token 'lbp))
  99.       200))
  100.  
  101. (defun rbp (token)
  102.   (or (and (symbol? token) (get token 'rbp))
  103.       200))
  104.  
  105. (defvar *parse-debug* nil)
  106.  
  107. (defun parse (rbp-level stream)
  108.   (if *parse-debug* (print `(parse ,rbp-level)))
  109.   (defun parse-loop (translation)
  110.     (if (< rbp-level (lbp (peek-token stream)))
  111.     (parse-loop (ledcall (read-token stream) translation stream))
  112.       (begin (if *parse-debug* (print translation))
  113.          translation)))
  114.   (parse-loop (nudcall (read-token stream) stream)))
  115.  
  116. (defun header (token)
  117.   (or (get token 'header) token))
  118.  
  119. (defun parse-prefix (token stream)
  120.   (list (header token)
  121.     (parse (rbp token) stream)))
  122.  
  123. (defun parse-infix (token left stream)
  124.   (list (header token)
  125.     left
  126.     (parse (rbp token) stream)))
  127.  
  128. (defun parse-nary (token left stream)
  129.   (cons (header token) (cons left (prsnary token stream))))
  130.  
  131. (defun parse-matchfix (token left stream)
  132.   (cons (header token)
  133.     (prsmatch (or (get token 'match) token)
  134.           stream)))
  135.  
  136. (defun prsnary (token stream)
  137.   (defun loop (l)
  138.     (if (eq? token (peek-token stream))
  139.     (begin (read-token stream)
  140.            (loop (cons (parse (rbp token) stream) l)))
  141.       (reverse l)))
  142.   (loop (list (parse (rbp token) stream))))
  143.  
  144. (defun prsmatch (token stream)
  145.   (if (eq? token (peek-token stream))
  146.       (begin (read-token stream)
  147.          nil)
  148.     (begin (defun loop (l)
  149.          (if (eq? token (peek-token stream))
  150.          (begin (read-token stream)
  151.             (reverse l))
  152.            (if (eq? 'COMMA (peek-token stream))
  153.            (begin (read-token stream)
  154.               (loop (cons (parse 10 stream) l)))
  155.          (error 'comma-or-match-not-found (read-token stream)))))
  156.        (loop (list (parse 10 stream))))))
  157.  
  158. (defun delim-err (token stream)
  159.   (error 'illegal-use-of-delimiter token))
  160.  
  161. (defun erb-error (token left stream)
  162.   (error 'too-many token))
  163.  
  164. (defun premterm-err (token stream)
  165.   (error 'premature-termination-of-input token))
  166.  
  167. (defmac (defprops form)
  168.   (defun loop (l result)
  169.     (if (null? l)
  170.     `(begin ,@result)
  171.       (loop (cddr l)
  172.         `((putprop ',(cadr form) ',(cadr l) ',(car l))
  173.           ,@result))))
  174.   (loop (cddr form) nil))
  175.  
  176.  
  177. (defprops $
  178.   lbp -1
  179.   nud premterm-err)
  180.  
  181. (defprops COMMA
  182.   lbp 10
  183.   nud delim-err)
  184.  
  185.  
  186. (defprops ]
  187.   nud delim-err
  188.   led erb-err
  189.   lbp 5)
  190.  
  191. (defprops [
  192.   nud open-paren-nud
  193.   led open-paren-led
  194.   lbp 200)
  195.  
  196. (defprops if
  197.   nud if-nud
  198.   rbp 45)
  199.  
  200. (defprops then
  201.   nud delim-err
  202.   lbp 5
  203.   rbp 25)
  204.  
  205. (defprops else
  206.   nud delim-err
  207.   lbp 5
  208.   rbp 25)
  209.  
  210. (defprops -
  211.   nud parse-prefix
  212.   led parse-nary
  213.   lbp 100
  214.   rbp 100)
  215.  
  216. (defprops +
  217.   nud parse-prefix
  218.   led parse-nary
  219.   lbp 100
  220.   rbp 100)
  221.  
  222. (defprops *
  223.   led parse-nary
  224.   lbp 120)
  225.  
  226. (defprops =
  227.   led parse-infix
  228.   lbp 80
  229.   rbp 80)
  230.  
  231. (defprops **
  232.   lbp 140
  233.   rbp 139
  234.   led parse-infix)
  235.  
  236. (defprops :=
  237.   led parse-infix
  238.   lbp 80
  239.   rbp 80)
  240.  
  241.  
  242. (defprops /
  243.   led parse-infix
  244.   lbp 120
  245.   rbp 120)
  246.  
  247. (defprops >
  248.   led parse-infix
  249.   lbp 80
  250.   rbp 80)
  251.  
  252. (defprops <
  253.   led parse-infix
  254.   lbp 80
  255.   rbp 80)
  256.  
  257. (defprops >=
  258.   led parse-infix
  259.   lbp 80
  260.   rbp 80)
  261.  
  262. (defprops <=
  263.   led parse-infix
  264.   lbp 80
  265.   rbp 80)
  266.  
  267. (defprops not
  268.   nud parse-prefix
  269.   lbp 70
  270.   rbp 70)
  271.  
  272. (defprops and
  273.   led parse-nary
  274.   lbp 65)
  275.  
  276. (defprops or
  277.   led parse-nary
  278.   lbp 60)
  279.  
  280.  
  281. (defun open-paren-nud (token stream)
  282.   (if (eq (peek-token stream) '])
  283.       nil
  284.     (let ((right (prsmatch '] stream)))
  285.       (if (cdr right)
  286.       (cons 'sequence right)
  287.     (car right)))))
  288.  
  289. (defun open-paren-led (token left stream)
  290.   (cons (header left) (prsmatch '] stream)))
  291.  
  292.  
  293. (defun if-nud (token stream)
  294.   (define pred (parse (rbp token) stream))
  295.   (define then (if (eq? (peek-token stream) 'then)
  296.            (parse (rbp (read-token stream)) stream)
  297.          (error 'missing-then)))
  298.   (if (eq? (peek-token stream) 'else)
  299.       `(if ,pred ,then ,(parse (rbp (read-token stream)) stream))
  300.     `(if ,pred ,then)))
  301.